#lang racket/base
(require openssl/mzssl
	 net/imap
	 mzlib/etc)

(define (test expect f . args)
  (define got (if (procedure? f)
                  (apply f args)
                  (car args)))
  (unless (equal? expect got)
    (error 'test "failed: ~s vs. ~s" expect got)))

;; ----------------------------------------

(define (try-connect username password expected-login)
  
  (define-values (ci so) (make-pipe))
  (define-values (si co) (make-pipe))
  
  (define got-login #f)
  
  (define t
    (thread (lambda ()
              (let loop ()
                (define l (read-line si))
                (define m (regexp-match #rx"^([a-z0-9]*) ([A-Z]+)(.*)\r$" l))
                (unless m (log-error "?? ~s" l))
                (define (reply s)
                  (fprintf so "~a ~a\r\n" (cadr m) s)
                  (flush-output so))
                (case (caddr m)
                  [("NOOP") (reply "OK NOOP completed")]
                  [("CAPABILITY") (reply "OK CAPABILITY completed")]
                  [("LOGIN") 
                   (set! got-login (cadddr m))
                   (reply "OK LOGIN completed")]
                  [("SELECT")
                   (reply "OK SELECT completed")]
                  [else
                   (log-error "?? ~s" l)])
                (loop)))))

  (imap-connect* ci co username password "INBOX")
  
  (test expected-login 'login got-login))


(try-connect "user" "password" " user password")
(for ([special-char (in-string "](){}\\%")])
  (try-connect "user"
               (format "pass~aword" special-char)
               (format " user \"pass~aword\"" special-char)))
  
;; ----------------------------------------

(define imap-config-file
  (build-path (find-system-path 'home-dir) ".imap-test-config"))

(when (file-exists? imap-config-file)
  (define config (with-input-from-file imap-config-file
                   read))

  (define imap-server (hash-ref config 'imap-server))
  (define imap-port-no (hash-ref config 'imap-port-no))
  (define username (hash-ref config 'username))
  (define pw (hash-ref config 'pw))
  (define mailbox-name (hash-ref config 'mailbox-name "INBOX.tmp")) ;; !!! ALL CONTENT WILL BE DELETED !!!

  (define (test-connect)
    (if (zero? (random 2))
        (parameterize ([imap-port-number 993])
          (imap-connect #:tls? #t imap-server username pw mailbox-name))
        (let ([c (ssl-make-client-context)])
          (let-values ([(in out) (ssl-connect imap-server imap-port-no c)])
            (imap-connect* in out username pw mailbox-name)))))

  (define-values (imap cnt recent) (test-connect))

  (printf "Msgs: ~a; Validity: ~a\n" cnt (imap-uidvalidity imap))

  (test cnt imap-messages imap)
  (test recent imap-recent imap)
  (test #t number? (imap-uidvalidity imap))
  (test #f imap-pending-expunges? imap)
  (test #f imap-pending-updates? imap)
  (test #f imap-new? imap)

  (define (delete-all)
    (let ([cnt (imap-messages imap)])
      (unless (zero? cnt)
        (let ([all (build-list cnt add1)])
          (test (void) imap-store imap '+ all '|\Deleted|)
          (test (void) imap-expunge imap)
          (test #t imap-pending-expunges? imap)
          (test all imap-get-expunges imap)
          (test null imap-get-expunges imap)
          (test #f imap-pending-expunges? imap)))))

  (delete-all)
  (test #f imap-new? imap)
  (test 0 imap-messages imap)
  (test '(0 0) 'noop (let-values ([(a b) (imap-noop imap)])
                       (list a b)))
  (test (void) imap-poll imap)
  (test 0 imap-messages imap)
  (test 0 imap-recent imap)

  (test #f imap-new? imap)

  (define (add-one content total)
    (test (void) imap-append imap mailbox-name content)
    (imap-noop imap)
    (test total imap-messages imap)
    (test #t imap-new? imap)
    (let ([uids (imap-get-messages imap (build-list total add1) '(uid))])
      (test #t list? uids)
      (test total length uids)
      (let ([l (list-ref uids (sub1 total))])
        (test #t list? l)
        (test 1 length l)
        (test #t number? (car l))
        (car l))))

  (define sample-head #"Subject: Hello\r\n\r\n")
  (define sample-body #"Hi there.\r\n")

  (let ([uid (add-one (bytes-append sample-head sample-body) 1)])
    (test (list (list uid 
                      sample-head
                      sample-body
                      '(|\Seen| |\Recent|)))
          imap-get-messages imap '(1) '(uid header body flags)))
  (test (void) imap-store imap '+ '(1) (list (symbol->imap-flag 'answered)))
  (test (list '((|\Answered| |\Seen| |\Recent|))) imap-get-messages imap '(1) '(flags))
  (test (void) imap-store imap '- '(1) (list (symbol->imap-flag 'answered)))
  (test (list '((|\Seen| |\Recent|))) imap-get-messages imap '(1) '(flags))
  (test (void) imap-store imap '+ '(1) (list (symbol->imap-flag 'deleted)))
  (test (list '((|\Deleted| |\Seen| |\Recent|))) imap-get-messages imap '(1) '(flags))
  (test (void) imap-store imap '! '(1) (list (symbol->imap-flag 'answered)))
  (test (list '((|\Answered| |\Recent|))) imap-get-messages imap '(1) '(flags))

  (test #f imap-pending-updates? imap)
  (test null imap-get-updates imap)

  ;; Test multiple-client access:
  (let ()
    (define-values (imap2 cnt2 recent2) (test-connect))
    (test '(1 0) list cnt2 recent2)
    
    (let ([uid (add-one (bytes-append sample-head sample-body) 2)])
      (let loop ([n 5])
        (when (zero? n)
          (imap-noop imap2))
        (imap-poll imap2)
        (unless (imap-new? imap2)
          (sleep 0.2)
          (loop (sub1 n))))
      (test #t imap-new? imap2)
      (test 2 imap-messages imap2)
      (let ([uids (imap-get-messages imap2 '(2) '(uid))])
        (test uid caar uids)))

    ;; Delete message on imap2, check notifcation to imap
    (test (void) imap-store imap2 '+ '(2) (list (symbol->imap-flag 'deleted)))
    (test (void) imap-expunge imap2)
    (test '(2) imap-get-expunges imap2)
    (imap-noop imap)
    (test 'exn values (with-handlers ([exn:fail:contract? (lambda (x) 'exn)])
                        (imap-store imap '+ '(2) (list (symbol->imap-flag 'answered)))))
    (test #t imap-pending-expunges? imap)
    (test '(2) imap-get-expunges imap)

    ;; Adjust flags on imap2, check notifcation to imap
    (test #f imap-pending-updates? imap)
    (test (void) imap-store imap2 '+ '(1) (list (symbol->imap-flag 'deleted)))
    (imap-noop imap)
    (test #t imap-pending-updates? imap)
    (test #t list? (imap-get-updates imap))
    (test #f imap-pending-updates? imap)

    ;; Check that multiple updates are collapsed:
    (test (void) imap-store imap2 '- '(1) (list (symbol->imap-flag 'deleted)))  
    (imap-noop imap)
    (test #t imap-pending-updates? imap)
    (test (void) imap-store imap2 '+ '(1) (list (symbol->imap-flag 'deleted)))
    (test (void) imap-store imap2 '- '(1) (list (symbol->imap-flag 'deleted)))
    (imap-noop imap)
    (test #t imap-pending-updates? imap)
    (test 1 length (imap-get-updates imap))
    
    (test (void) imap-reset-new! imap2)
    (add-one (bytes-append sample-head sample-body) 2)
    (add-one (bytes-append sample-head sample-body) 3)
    (add-one (bytes-append sample-head sample-body) 4)
    (add-one (bytes-append sample-head sample-body) 5)
    (imap-noop imap2)
    (test #t imap-new? imap2)
    (test 5 imap-messages imap)
    (test 5 imap-messages imap2)

    (test #t list? (imap-get-messages imap '(1 2 3 4 5) '(uid)))
    (test #t list? (imap-get-messages imap2 '(1 2 3 4 5) '(uid)))
    
    ;; Test deleteing multiple messages, and shifts in flag updates
    (test (void) imap-store imap2 '+ '(2 4) (list (symbol->imap-flag 'deleted)))
    (test (void) imap-store imap2 '+ '(3 5) (list (symbol->imap-flag 'answered)))
    (test (void) imap-expunge imap2)
    (imap-noop imap)
    (imap-noop imap2)
    (test #t imap-pending-expunges? imap)
    (test #t imap-pending-expunges? imap2)
    (test '(2 4) imap-get-expunges imap)
    (test '(2 4) imap-get-expunges imap2)
    (test #t imap-pending-updates? imap)
    (test '(2 3) map car (imap-get-updates imap))

    (imap-disconnect imap2))

  (imap-disconnect imap)
  
  (printf "tests passed\n"))




